(SETQ IBASE (ADD1 7)) 


(DEFPROP ALLFNS 
 (NIL SAVE
      GEOINIT
      FOO
      WAIT
      RUNNER
      FATAL
      TJOINT
      K1
      G
      FOLDED
      VISIBLE
      POTENT
      JOTBIT
      JUTBIT
      EBIT
      MAKETILE
      DETSEG
      SHOW9
      *TEST
      EXCH
      SEENOD
      GLUETILE
      TEST2
      TEST
      TYPE
      COPYPOS
      GARG) 
VALUE)

(DEFPROP SAVE 
 (LAMBDA (L) (EVAL (LIST (QUOTE DSKOUT) (CAR L) (QUOTE (PROG2 (GRINL ALLFNS) (PRINT (QUOTE (GEOINIT)))))))) 
FEXPR)

(DEFPROP GEOINIT 
 (LAMBDA NIL (PROG2 START (DEPOSIT 124 (MAKNUM (GETQ START VALUE) (QUOTE FIXNUM))) (GEONIT) (DETSEG))) 
EXPR)

(DEFPROP FOO 
 (LAMBDA(L)
  (PROG NIL
	(MAPC (FUNCTION (LAMBDA (L) (GPUSH (EVAL L)))) L)
	(STADPY)
	(MAPC (FUNCTION (LAMBDA (L) (GPOP L))) L))) 
FEXPR)

(DEFPROP WAIT 
 (LAMBDA NIL
  (PROG (TMP TMP2)
	(SETQ TMP (DDTIN T))
	(SETQ TMP2 (TYI))
	(DDTIN TMP)
	(COND ((EQ TMP2 104) (BREAK WAIT)) (T NIL)))) 
EXPR)

(DEFPROP RUNNER 
 (LAMBDA NIL
  (PROG NIL
	(SHOW9 1)
	(TEST2)
	(PRINQ PASS 1 COMPLETED /././.)
	(*TEST)
	(PRINQ PASS2 COMPLETED)
	(TERPRI)
	(KLTMPS WORLD)
	(GEODPY)
	(GPUSH IMAGE)
	(STADPY))) 
EXPR)

(DEFPROP FATAL 
 (LAMBDA (L) (PROG2 NIL (PRINL L) (BREAK (FATAL)) (FIX T))) 
FEXPR)

(DEFPROP TJOINT 
 (LAMBDA (N) (NED N)) 
EXPR)

(DEFPROP K1 
 (NIL . 0.13698630E-1) 
VALUE)

(DEFPROP G 
 (LAMBDA NIL (PROG2 (COND ((EQ WORLD 0) (GEOINIT)) (T NIL)) (GEOMED))) 
EXPR)

(DEFPROP FOLDED 
 (NIL . 100000000) 
VALUE)

(DEFPROP VISIBLE 
 (NIL . 40000000) 
VALUE)

(DEFPROP POTENT 
 (NIL . 20000000) 
VALUE)

(DEFPROP JOTBIT 
 (NIL . 20000000000) 
VALUE)

(DEFPROP JUTBIT 
 (NIL . 40000000000) 
VALUE)

(DEFPROP EBIT 
 (NIL . 4000000) 
VALUE)

(DEFPROP MAKETILE 
 (LAMBDA(CALLFACE)
  (PROG (FACE E0 E1 FNEW VNEW V0 VT JOTFLAG EOP VOP)
	(PROG2 (GPUSH CALLFACE) (STADPY) (GPOP))
	(SETQ E0 (SETQ E1 (PED CALLFACE)))
	(SETQ E1 E0)
   VSLOOP
	(COND ((TEST E1 VISIBLE) NIL)
	      ((EQ E0 (SETQ E1 (ECCW E1 CALLFACE)))
	       (RETURN (PROG2 (PRINQ POTENT FACE WITHOUT VISIBLE EDGE FOUND) 0)))
	      (T (GO VSLOOP)))
	(SETQ JOTFLAG NIL)
	(SETQ FACE CALLFACE)
	(SETQ E0 E1)
	(SETQ FNEW (MKF IMAGE))
	(SETQ V0 (MKV IMAGE))
	(SETQ VNEW V0)
	(SETQ EOP (FUNCTION ECCW))
	(SETQ VOP (FUNCTION VCCW))
   LOOP (COPYPOS VNEW (VOP E1 FACE))
	(PROG NIL (GPUSH FACE) (GPUSH E1) (STADPY) (WAIT) (GPOP) (GPOP))
	(COND
	 (JOTFLAG
	  (COND
	   ((AND (TEST (VCCW E1 FACE) (*PLUS JUTBIT JOTBIT))
		 (OR (TEST (PED (SETQ VT (TJOINT (VCCW E1 FACE)))) VISIBLE) (TEST (ECCW (PED VT) VT) VISIBLE)))
	    (PROG NIL
		  (SETQ FACE (PFACE (PED VT)))
		  (COND ((TEST FACE POTENT)
			 (COND ((EQ FACE CALLFACE) (SETQ JOTFLAG NIL)) (T (SETQ FACE (NFACE (PED VT))))))
			((EQ (NFACE (PED VT)) CALLFACE) (PROG NIL (SETQ FACE CALLFACE) (SETQ JOTFLACE T)))
			(T NIL))
		  (SETQ E1 (ECCW VT FACE))))
	   (T
	    (PROG NIL
		  (SETQ VT (VCCW E1 FACE))
 	     ELOOP
		  (COND ((TEST (SETQ E1 (ECW E1 VT)) VISIBLE) NIL) (T (GO ELOOP)))
		  (SETQ FACE (FCCW E1 VT))))))
	 ((TEST (ECCW E1 FACE) VISIBLE) (SETQ E1 (ECCW E1 FACE)))
	 ((NULL (EQ (TJOINT (SETQ VT (VCCW E1 FACE))) 0))
	  (PROG NIL
		(SETQ VT (TJOINT VT))
		(PROG2 (GPUSH VT) (STADPY) (GPOP))
		(SETQ FACE (PFACE (PED VT)))
		(COND ((TEST FACE POTENT) (SETQ FACE (NFACE (PED VT)))) (T NIL))
		(SETQ E1 (ECCW VT FACE))
		(SETQ JOTFLAG NIL)))
	 (T
	  (PROG NIL
		(SETQ E1 (ECCW E1 FACE))
 	   ELOOP
		(PROG NIL (GPUSH VT) (GPUSH E1) (STADPY) (GPOP) (GPOP))
		(COND ((TEST (SETQ E1 (ECW E1 VT)) VISIBLE) NIL) (T (GO ELOOP)))
		(SETQ FACE (FCCW E1 VT))
		(SETQ JOTFLAG T))))
	(COND ((EQ E0 E1)
	       (RETURN
		(PROG NIL
		      (SETQ E0 (INVERT (MKFE V0 FNEW VNEW)))
		      (ALT/. E1 E0)
		      (ALT/. E0 E1)
		      (SETQ FNEW (PFACE FNEW))
		      (ALT/. FACE FNEW)
		      (ALT/. FNEW FACE)
		      (RETURN FNEW))))
	      (T (SETQ VNEW (MKEV FNEW VNEW))))
	(ALT/. E1 (PED VNEW))
	(ALT/. (PED VNEW) E1)
	(GO LOOP))) 
EXPR)

(DEFPROP DETSEG 
 (LAMBDA NIL (UUO 400017)) 
EXPR)

(DEFPROP SHOW9 
 (LAMBDA(POG)
  (PROG NIL (PPROJ CAMERA WORLD) (FMRK WORLD) (EMRK WORLD) (OCCULT WORLD) (CLIPER WINDOW) (IIIDPY WINDOW POG))) 
EXPR)

(DEFPROP *TEST 
 (LAMBDA NIL
  (PROG (E1 E2)
	(SETQ E1 (PED IMAGE))
   LOOP (PROG2 (GPUSH (ALT E1)) (STADPY) (GPOP))
	(COND ((EQ E1 (SETQ E2 (ALT (ALT E1)))) NIL)
	      ((NULL (TEST E1 EBIT)) (FATAL E1 NOT AN EDGE))
	      ((NULL (TEST E2 EBIT)) (FATAL E2 NOT AN EDGE))
	      (T (PROG NIL (GLUETILE E2 E1) (ALT/. (ALT E1) E1))))
	(COND ((EQ (SETQ E1 (PED E1)) IMAGE) (RETURN)) (T (GO LOOP))))) 
EXPR)

(DEFPROP EXCH 
 (LAMBDA (L) (PROG (TMP) (SETQ TMP (EVAL (CAR L))) (SET (CAR L) (EVAL (CADR L))) (SET (CADR L) TMP))) 
FEXPR)

(DEFPROP SEENOD 
 (LAMBDA (L) (PROG NIL (GPUSH L) (GEODPY) (STADPY) (GPOP))) 
EXPR)

(DEFPROP GLUETILE 
 (LAMBDA(E1 E2)
  (PROG (UF1 UF2 ENEW1 ENEW2 V1 V2 U1 U2)
	(SETQ V1 (NVT E1))
	(SETQ V2 (PVT E1))
	(SETQ U1 (PVT E2))
	(SETQ U2 (NVT E2))
	(SETQ UF1 (NFACE E1))
	(SETQ UF2 (NFACE E2))
	(RETURN
	 (COND ((AND (EQ V1 U1) (EQ V2 U2)) (PROG NIL (KLFE E1) (RETURN E2)))
	       ((OR (EQ V1 U1) (EQ V2 U2))
		(PROG NIL
		      (COND ((EQ V2 U2) (SETQ ENEW1 (MKFE U1 UF1 V1))) (T (SETQ ENEW1 (MKFE V2 UF1 U2))))
		      (KLFE E1)
		      (KLVE ENEW1)
		      (RETURN E2)))
	       (T
		(PROG NIL
		      (COND ((OR (EQ V1 U2) (EQ V2 U1)) (BREAK (EDGE BACKWARDS AT GLUETILE))) (T NIL))
		      (SETQ ENEW1 (GLUEE UF1 V1 UF2 U1))
		      (SETQ ENEW2 (MKFE V2 UF1 U2))
		      (KLFE E1)
		      (KLVE ENEW1)
		      (KLVE ENEW2)
		      (RETURN E2))))))) 
EXPR)

(DEFPROP TEST2 
 (LAMBDA NIL
  (PROG (FACE)
	(SETQ IMAGE (MKB WORLD))
	(SETQ FACE (PFACE WORLD))
   LOOP (MAKETILE FACE)
	(SETQ FACE (ALT2 FACE))
	(COND ((EQ FACE 0) (RETURN T)) (T (GO LOOP))))) 
EXPR)

(DEFPROP TEST 
 (LAMBDA (NODE BITS) (NOT (EQ (BOOLE 1 (TYPE NODE) BITS) 0))) 
EXPR)

(DEFPROP TYPE 
 (LAMBDA (N) (ZWC (ADD1 N))) 
EXPR)

(DEFPROP COPYPOS 
 (LAMBDA(VNEW VOLD)
  (PROG NIL
	(ZWC/. VNEW 0)
	(XWC/. VNEW (*TIMES K1 (XDC VOLD)))
	(YWC/. VNEW (*TIMES K1 (YDC VOLD)))
	(XDC/. VNEW (XDC VOLD))
	(YDC/. VNEW (YDC VOLD)))) 
EXPR)

(DEFPROP GARG 
 (LAMBDA (N) (EXAMINE (*DIF (BOOLE 1 PDLPTR 777777) (SUB1 N)))) 
EXPR)

(GEOINIT)